home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xldmem.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  11KB  |  566 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* useful definitions */
  9. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  10.  
  11. /* external variables */
  12. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  13. extern NODE *obarray;
  14. extern NODE *xlenv;
  15. extern long total;
  16. extern int anodes,nnodes,nsegs,nfree,gccalls;
  17. extern struct segment *segs;
  18. extern NODE *fnodes;
  19. extern char buf[];
  20.  
  21. /* external procedures */
  22. extern char *malloc();
  23. extern char *calloc();
  24.  
  25. /* forward declarations */
  26. FORWARD NODE *newnode();
  27. FORWARD char *strsave();
  28. FORWARD char *stralloc();
  29.  
  30. /* cons - construct a new cons node */
  31. NODE *cons(x,y)
  32.   NODE *x,*y;
  33. {
  34.     NODE *val;
  35.     val = newnode(LIST);
  36.     rplaca(val,x);
  37.     rplacd(val,y);
  38.     return (val);
  39. }
  40.  
  41. /* consa - (cons x nil) */
  42. NODE *consa(x)
  43.   NODE *x;
  44. {
  45.     NODE *val;
  46.     val = newnode(LIST);
  47.     rplaca(val,x);
  48.     return (val);
  49. }
  50.  
  51. /* consd - (cons nil x) */
  52. NODE *consd(x)
  53.   NODE *x;
  54. {
  55.     NODE *val;
  56.     val = newnode(LIST);
  57.     rplacd(val,x);
  58.     return (val);
  59. }
  60.  
  61. /* cvstring - convert a string to a string node */
  62. NODE *cvstring(str)
  63.   char *str;
  64. {
  65.     NODE ***oldstk,*val;
  66.     oldstk = xlsave(&val,NULL);
  67.     val = newnode(STR);
  68.     val->n_str = strsave(str);
  69.     val->n_strtype = DYNAMIC;
  70.     xlstack = oldstk;
  71.     return (val);
  72. }
  73.  
  74. /* cvcstring - convert a constant string to a string node */
  75. NODE *cvcstring(str)
  76.   char *str;
  77. {
  78.     NODE *val;
  79.     val = newnode(STR);
  80.     val->n_str = str;
  81.     val->n_strtype = STATIC;
  82.     return (val);
  83. }
  84.  
  85. /* cvsymbol - convert a string to a symbol */
  86. NODE *cvsymbol(pname)
  87.   char *pname;
  88. {
  89.     NODE ***oldstk,*val;
  90.     oldstk = xlsave(&val,NULL);
  91.     val = newnode(SYM);
  92.     val->n_symplist = newnode(LIST);
  93.     rplaca(val->n_symplist,cvstring(pname));
  94.     xlstack = oldstk;
  95.     return (val);
  96. }
  97.  
  98. /* cvcsymbol - convert a constant string to a symbol */
  99. NODE *cvcsymbol(pname)
  100.   char *pname;
  101. {
  102.     NODE ***oldstk,*val;
  103.     oldstk = xlsave(&val,NULL);
  104.     val = newnode(SYM);
  105.     val->n_symplist = newnode(LIST);
  106.     rplaca(val->n_symplist,cvcstring(pname));
  107.     xlstack = oldstk;
  108.     return (val);
  109. }
  110.  
  111. /* cvsubr - convert a function to a subr or fsubr */
  112. NODE *cvsubr(fcn,type)
  113.   NODE *(*fcn)(); int type;
  114. {
  115.     NODE *val;
  116.     val = newnode(type);
  117.     val->n_subr = fcn;
  118.     return (val);
  119. }
  120.  
  121. /* cvfile - convert a file pointer to a file */
  122. NODE *cvfile(fp)
  123.   FILE *fp;
  124. {
  125.     NODE *val;
  126.     val = newnode(FPTR);
  127.     setfile(val,fp);
  128.     setsavech(val,0);
  129.     return (val);
  130. }
  131.  
  132. /* cvfixnum - convert an integer to a fixnum node */
  133. NODE *cvfixnum(n)
  134.   FIXNUM n;
  135. {
  136.     NODE *val;
  137.     val = newnode(INT);
  138.     val->n_int = n;
  139.     return (val);
  140. }
  141.  
  142. /* cvflonum - convert a floating point number to a flonum node */
  143. NODE *cvflonum(n)
  144.   FLONUM n;
  145. {
  146.     NODE *val;
  147.     val = newnode(FLOAT);
  148.     val->n_float = n;
  149.     return (val);
  150. }
  151.  
  152. /* newstring - allocate and initialize a new string */
  153. NODE *newstring(size)
  154.   int size;
  155. {
  156.     NODE ***oldstk,*val;
  157.     oldstk = xlsave(&val,NULL);
  158.     val = newnode(STR);
  159.     val->n_str = stralloc(size);
  160.     *getstring(val) = 0;
  161.     val->n_strtype = DYNAMIC;
  162.     xlstack = oldstk;
  163.     return (val);
  164. }
  165.  
  166. /* newobject - allocate and initialize a new object */
  167. NODE *newobject(cls,size)
  168.   NODE *cls; int size;
  169. {
  170.     NODE *val;
  171.     val = newvector(size+1);
  172.     setelement(val,0,cls);
  173.     val->n_type = OBJ;
  174.     return (val);
  175. }
  176.  
  177. /* newvector - allocate and initialize a new vector node */
  178. NODE *newvector(size)
  179.   int size;
  180. {
  181.     NODE ***oldstk,*vect;
  182.     int bsize;
  183.  
  184.     /* establish a new stack frame */
  185.     oldstk = xlsave(&vect,NULL);
  186.  
  187.     /* allocate a vector node and set the size to zero (in case of gc) */
  188.     vect = newnode(VECT);
  189.     vect->n_vsize = 0;
  190.  
  191.     /* allocate memory for the vector */
  192.     bsize = size * sizeof(NODE *);
  193.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  194.     findmem();
  195.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  196.         xlfail("insufficient vector space");
  197.     }
  198.     vect->n_vsize = size;
  199.     total += (long) bsize;
  200.  
  201.     /* restore the previous stack frame */
  202.     xlstack = oldstk;
  203.  
  204.     /* return the new vector */
  205.     return (vect);
  206. }
  207.  
  208. /* newnode - allocate a new node */
  209. LOCAL NODE *newnode(type)
  210.   int type;
  211. {
  212.     NODE *nnode;
  213.  
  214.     /* get a free node */
  215.     if ((nnode = fnodes) == NIL) {
  216.     findmem();
  217.     if ((nnode = fnodes) == NIL)
  218.         xlabort("insufficient node space");
  219.     }
  220.  
  221.     /* unlink the node from the free list */
  222.     fnodes = cdr(nnode);
  223.     nfree -= 1;
  224.  
  225.     /* initialize the new node */
  226.     nnode->n_type = type;
  227.     rplacd(nnode,NIL);
  228.  
  229.     /* return the new node */
  230.     return (nnode);
  231. }
  232.  
  233. /* stralloc - allocate memory for a string adding a byte for the terminator */
  234. LOCAL char *stralloc(size)
  235.   int size;
  236. {
  237.     char *sptr;
  238.  
  239.     /* allocate memory for the string copy */
  240.     if ((sptr = malloc(size+1)) == NULL) {
  241.     findmem();  
  242.     if ((sptr = malloc(size+1)) == NULL)
  243.         xlfail("insufficient string space");
  244.     }
  245.     total += (long) (size+1);
  246.  
  247.     /* return the new string memory */
  248.     return (sptr);
  249. }
  250.  
  251. /* strsave - generate a dynamic copy of a string */
  252. LOCAL char *strsave(str)
  253.   char *str;
  254. {
  255.     char *sptr;
  256.  
  257.     /* create a new string */
  258.     sptr = stralloc(strlen(str));
  259.     strcpy(sptr,str);
  260.  
  261.     /* return the new string */
  262.     return (sptr);
  263. }
  264.  
  265. /* strfree - free a string */
  266. LOCAL strfree(str)
  267.   char *str;
  268. {
  269.     total -= (long) (strlen(str)+1);
  270.     free(str);
  271. }
  272.  
  273. /* findmem - find more memory by collecting then expanding */
  274. findmem()
  275. {
  276.     gc();
  277.     if (nfree < anodes)
  278.     addseg();
  279. }
  280.  
  281. /* gc - garbage collect */
  282. gc()
  283. {
  284.     NODE ***p;
  285.     void mark();
  286.  
  287.     /* mark the obarray and the current environment */
  288.     mark(obarray);
  289.     mark(xlenv);
  290.  
  291.     /* mark the evaluation stack */
  292.     for (p = xlstack; p < xlstktop; )
  293.     mark(**p++);
  294.  
  295.     /* sweep memory collecting all unmarked nodes */
  296.     sweep();
  297.  
  298.     /* count the gc call */
  299.     gccalls++;
  300. }
  301.  
  302. /* mark - mark all accessible nodes */
  303. void mark(ptr)
  304.   NODE *ptr;
  305. {
  306.     NODE *this,*prev,*tmp;
  307.  
  308.     /* just return on nil */
  309.     if (ptr == NIL)
  310.     return;
  311.  
  312.     /* initialize */
  313.     prev = NIL;
  314.     this = ptr;
  315.  
  316.     /* mark this list */
  317.     while (TRUE) {
  318.  
  319.     /* descend as far as we can */
  320.     while (TRUE) {
  321.  
  322.         /* check for this node being marked */
  323.         if (this->n_flags & MARK)
  324.         break;
  325.  
  326.         /* mark it and its descendants */
  327.         else {
  328.  
  329.         /* mark the node */
  330.         this->n_flags |= MARK;
  331.  
  332.         /* follow the left sublist if there is one */
  333.         if (livecar(this)) {
  334.             this->n_flags |= LEFT;
  335.             tmp = prev;
  336.             prev = this;
  337.             this = car(prev);
  338.             rplaca(prev,tmp);
  339.         }
  340.  
  341.         /* otherwise, follow the right sublist if there is one */
  342.         else if (livecdr(this)) {
  343.             this->n_flags &= ~LEFT;
  344.             tmp = prev;
  345.             prev = this;
  346.             this = cdr(prev);
  347.             rplacd(prev,tmp);
  348.         }
  349.         else
  350.             break;
  351.         }
  352.     }
  353.  
  354.     /* backup to a point where we can continue descending */
  355.     while (TRUE) {
  356.  
  357.         /* check for termination condition */
  358.         if (prev == NIL)
  359.         return;
  360.  
  361.         /* check for coming from the left side */
  362.         if (prev->n_flags & LEFT)
  363.         if (livecdr(prev)) {
  364.             prev->n_flags &= ~LEFT;
  365.             tmp = car(prev);
  366.             rplaca(prev,this);
  367.             this = cdr(prev);
  368.             rplacd(prev,tmp);
  369.             break;
  370.         }
  371.         else {
  372.             tmp = prev;
  373.             prev = car(tmp);
  374.             rplaca(tmp,this);
  375.             this = tmp;
  376.         }
  377.  
  378.         /* otherwise, came from the right side */
  379.         else {
  380.         tmp = prev;
  381.         prev = cdr(tmp);
  382.         rplacd(tmp,this);
  383.         this = tmp;
  384.         }
  385.     }
  386.     }
  387. }
  388.  
  389. /* vmark - mark a vector */
  390. vmark(n)
  391.   NODE *n;
  392. {
  393.     int i;
  394.     for (i = 0; i < getsize(n); ++i)
  395.     mark(getelement(n,i));
  396. }
  397.  
  398. /* sweep - sweep all unmarked nodes and add them to the free list */
  399. LOCAL sweep()
  400. {
  401.     struct segment *seg;
  402.     NODE *p;
  403.     int n;
  404.  
  405.     /* empty the free list */
  406.     fnodes = NIL;
  407.     nfree = 0;
  408.  
  409.     /* add all unmarked nodes */
  410.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  411.     p = &seg->sg_nodes[0];
  412.     for (n = seg->sg_size; n--; p++)
  413.         if (!(p->n_flags & MARK)) {
  414.         switch (ntype(p)) {
  415.         case STR:
  416.             if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
  417.                 total -= (long) (strlen(p->n_str)+1);
  418.                 free(p->n_str);
  419.             }
  420.             break;
  421.         case FPTR:
  422.             if (p->n_fp)
  423.                 fclose(p->n_fp);
  424.             break;
  425.         case VECT:
  426.             if (p->n_vsize) {
  427.                 total -= (long) (p->n_vsize * sizeof(NODE **));
  428.                 free(p->n_vdata);
  429.             }
  430.             break;
  431.         }
  432.         p->n_type = FREE;
  433.         p->n_flags = 0;
  434.         rplaca(p,NIL);
  435.         rplacd(p,fnodes);
  436.         fnodes = p;
  437.         nfree++;
  438.         }
  439.         else
  440.         p->n_flags &= ~(MARK | LEFT);
  441.     }
  442. }
  443.  
  444. /* addseg - add a segment to the available memory */
  445. int addseg()
  446. {
  447.     struct segment *newseg;
  448.     NODE *p;
  449.     int n;
  450.  
  451.     /* check for zero allocation */
  452.     if (anodes == 0)
  453.     return (FALSE);
  454.  
  455.     /* allocate a new segment */
  456.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  457.  
  458.     /* initialize the new segment */
  459.     newseg->sg_size = anodes;
  460.     newseg->sg_next = segs;
  461.     segs = newseg;
  462.  
  463.     /* add each new node to the free list */
  464.     p = &newseg->sg_nodes[0];
  465.     for (n = anodes; n--; ) {
  466.         rplacd(p,fnodes);
  467.         fnodes = p++;
  468.     }
  469.  
  470.     /* update the statistics */
  471.     total += (long) ALLOCSIZE;
  472.     nnodes += anodes;
  473.     nfree += anodes;
  474.     nsegs++;
  475.  
  476.     /* return successfully */
  477.     return (TRUE);
  478.     }
  479.     else
  480.     return (FALSE);
  481. }
  482.  
  483. /* livecar - do we need to follow the car? */
  484. LOCAL int livecar(n)
  485.   NODE *n;
  486. {
  487.     switch (ntype(n)) {
  488.     case OBJ:
  489.     case VECT:
  490.         vmark(n);
  491.     case SUBR:
  492.     case FSUBR:
  493.     case INT:
  494.     case FLOAT:
  495.     case STR:
  496.     case FPTR:
  497.         return (FALSE);
  498.     case SYM:
  499.     case LIST:
  500.         return (car(n) != NIL);
  501.     default:
  502.         printf("bad node type (%d) found during left scan\n",ntype(n));
  503.         osfinish ();
  504.         exit();
  505.     }
  506. }
  507.  
  508. /* livecdr - do we need to follow the cdr? */
  509. LOCAL int livecdr(n)
  510.   NODE *n;
  511. {
  512.     switch (ntype(n)) {
  513.     case SUBR:
  514.     case FSUBR:
  515.     case INT:
  516.     case FLOAT:
  517.     case STR:
  518.     case FPTR:
  519.     case OBJ:
  520.     case VECT:
  521.         return (FALSE);
  522.     case SYM:
  523.     case LIST:
  524.         return (cdr(n) != NIL);
  525.     default:
  526.         printf("bad node type (%d) found during right scan\n",ntype(n));
  527.         osfinish ();
  528.         exit();
  529.     }
  530. }
  531.  
  532. /* stats - print memory statistics */
  533. stats()
  534. {
  535.     sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
  536.     sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
  537.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  538.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  539.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  540.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  541. }
  542.  
  543. /* xlminit - initialize the dynamic memory module */
  544. xlminit()
  545. {
  546.     /* initialize our internal variables */
  547.     anodes = NNODES;
  548.     total = 0L;
  549.     nnodes = nsegs = nfree = gccalls = 0;
  550.     fnodes = NIL;
  551.     segs = NULL;
  552.  
  553.     /* initialize structures that are marked by the collector */
  554.     xlenv = obarray = NIL;
  555.  
  556.     /* allocate the evaluation stack */
  557.     if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
  558.     printf("insufficient memory");
  559.     osfinish ();
  560.     exit();
  561.     }
  562.     total += (long)(EDEPTH * sizeof(NODE **));
  563.     xlstack = xlstktop = xlstkbase + EDEPTH;
  564. }
  565.  
  566.